home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / library.tcl < prev    next >
Encoding:
Text File  |  1997-12-20  |  17.9 KB  |  634 lines  |  [TEXT/ALFA]
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  10. # Some copyright (c) 1997 Vince Darley.
  11.  
  12. set errorCode ""
  13. set errorInfo ""
  14.  
  15. if {[info commands tclLog] == ""} {
  16.     proc tclLog {string} {
  17.         message $string
  18.     }
  19. }
  20. # so we can write a few things which are Tcl 8.0 compatible
  21. if {[info tclversion] < 8.0} {
  22.     ;proc namespace {cmd ns script} {if {$script != ""} {uplevel $script}}
  23.     ;proc variable args {uplevel global $args}
  24.     ;proc namesp {var} {}
  25. } else {
  26.     namespace eval alpha {}
  27.     namespace eval procs {}
  28.     namespace eval index {}
  29.     # used to force some child namespaces into existence
  30.     ;proc namesp {var} {
  31.         if [catch "uplevel global $var"] {
  32.             set ns ""
  33.             while {[regexp "^(::)?($ns\[a-zA-Z_\]+::)" $var ns]} {
  34.                 uplevel "namespace eval $ns {}"
  35.             }
  36.         }
  37.     }
  38. }
  39.  
  40. ## 
  41.  # -------------------------------------------------------------------------
  42.  # 
  43.  # "unknown" --
  44.  # 
  45.  #  Almost the same as standard Tcl 8 unknown.  Since we're on a Mac,
  46.  #  I removed the auto_execok flag, and for some reason had to change
  47.  #  'history change $newcmd 0' to 'history change $newcmd'
  48.  # -------------------------------------------------------------------------
  49.  ##
  50. # unknown --
  51. # This procedure is called when a Tcl command is invoked that doesn't
  52. # exist in the interpreter.  It takes the following steps to make the
  53. # command available:
  54. #
  55. #    1. See if the autoload facility can locate the command in a
  56. #       Tcl script file.  If so, load it and execute it.
  57. #    2. If the command was invoked interactively at top-level:
  58. #        (a) see if the command exists as an executable UNIX program.
  59. #        If so, "exec" the command.
  60. #        (b) see if the command requests csh-like history substitution
  61. #        in one of the common forms !!, !<number>, or ^old^new.  If
  62. #        so, emulate csh's history substitution.
  63. #        (c) see if the command is a unique abbreviation for another
  64. #        command.  If so, invoke the command.
  65. #
  66. # Arguments:
  67. # args -    A list whose elements are the words of the original
  68. #        command, including the command name.
  69. proc unknown args {
  70.     global auto_noload env unknown_pending tcl_interactive
  71.     global errorCode errorInfo
  72.  
  73.     # Save the values of errorCode and errorInfo variables, since they
  74.     # may get modified if caught errors occur below.  The variables will
  75.     # be restored just before re-executing the missing command.
  76.  
  77.     set savedErrorCode $errorCode
  78.     set savedErrorInfo $errorInfo
  79.     set name [lindex $args 0]
  80.     if ![info exists auto_noload] {
  81.         #
  82.         # Make sure we're not trying to load the same proc twice.
  83.         #
  84.         if [info exists unknown_pending($name)] {
  85.             return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  86.         }
  87.         set unknown_pending($name) pending;
  88.         set ret [catch {auto_load $name} msg]
  89.         unset unknown_pending($name);
  90.         if {$ret != 0} {
  91.             return -code $ret -errorcode $errorCode \
  92.               "error while autoloading \"$name\": $msg"
  93.         }
  94.         if ![array size unknown_pending] {
  95.             unset unknown_pending
  96.         }
  97.         if $msg {
  98.             set errorCode $savedErrorCode
  99.             set errorInfo $savedErrorInfo
  100.             set code [catch {uplevel 1 $args} msg]
  101.             if {$code ==  1} {
  102.                 #
  103.                 # Strip the last five lines off the error stack (they're
  104.                 # from the "uplevel" command).
  105.                 #
  106.                 
  107.                 set new [split $errorInfo \n]
  108.                 set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  109.                 return -code error -errorcode $errorCode \
  110.                   -errorinfo $new $msg
  111.             } else {
  112.                 return -code $code $msg
  113.             }
  114.         }
  115.     }
  116.     if {([info level] == 1) && ([info script] == "") \
  117.       && [info exists tcl_interactive] && $tcl_interactive} {
  118.         set errorCode $savedErrorCode
  119.         set errorInfo $savedErrorInfo
  120.         if {$name == "!!"} {
  121.             set newcmd [history event]
  122.         } elseif {[regexp {^!(.+)$} $name dummy event]} {
  123.             set newcmd [history event $event]
  124.         } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  125.             set newcmd [history event -1]
  126.             catch {regsub -all -- $old $newcmd $new newcmd}
  127.         }
  128.         if [info exists newcmd] {
  129.             tclLog $newcmd
  130.             history change $newcmd
  131.             return [uplevel $newcmd]
  132.         }
  133.  
  134.         set ret [catch {set cmds [info commands $name*]} msg]
  135.         if {[string compare $name "::"] == 0} {
  136.             set name ""
  137.         }
  138.         if {$ret != 0} {
  139.             return -code $ret -errorcode $errorCode \
  140.               "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  141.         }
  142.         if {[llength $cmds] == 1} {
  143.             return [uplevel [lreplace $args 0 0 $cmds]]
  144.         }
  145.         if {[llength $cmds] != 0} {
  146.             if {$name == ""} {
  147.                 return -code error "empty command name \"\""
  148.             } else {
  149.                 return -code error \
  150.                   "ambiguous command name \"$name\": [lsort $cmds]"
  151.             }
  152.         }
  153.     }
  154.     return -code error "invalid command name \"$name\""
  155. }
  156.  
  157. ## 
  158.  # -------------------------------------------------------------------------
  159.  # 
  160.  # "auto_load" --
  161.  # 
  162.  #  I use this separate proc to be closer to the standard Tcl 8 system
  163.  #  of unknown-loading.
  164.  # -------------------------------------------------------------------------
  165.  ##
  166. proc auto_load cmd {
  167.     set f [procs::find $cmd]
  168.     if {$f != ""} {
  169.         uplevel \#0 source [list $f]
  170.         return [expr {[info commands $cmd] != ""}]
  171.     }
  172.     return 0
  173. }
  174.  
  175. # auto_mkindex:
  176. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  177. # the name of the directory in which the tclIndex file is to be placed,
  178. # and a glob pattern to use in that directory to locate all of the relevant
  179. # files.
  180. proc auto_mkindex {dir {files *.tcl}} {    
  181.     set oldDir [pwd]
  182.     cd $dir
  183.     append line "# Tcl autoload index file: each line identifies a file (nowrap)\n\n"
  184.     append line "set \"[file tail [string trim [pwd] :]]_index\" \{\n"
  185.  
  186.     set cid [scancontext create]
  187.     scanmatch $cid {^proc[     ]} {
  188.         if {[regexp {^proc[     ]+(("[^"]+")|(\{[^\}]+\})|([^     ]*))} $matchInfo(line) match procName]} {
  189.             append line "$procName "
  190.         }
  191.     }
  192.  
  193.     foreach file [glob $files] {
  194.         watchCursor
  195.         set f ""
  196.         append line "\{[file tail $file]\14 "
  197.         message [file tail $file]
  198.         set fid [open $file]
  199.         scanfile $cid $fid
  200.         close $fid
  201.         append line "\}\n"
  202.     }
  203.     
  204.     scancontext delete $cid
  205.  
  206.     append line "\}\n"
  207.     catch {
  208.         set f [open tclIndexx w]
  209.         puts -nonewline $f $line
  210.         close $f
  211.     }
  212.     cd $oldDir
  213.  
  214.     foreach i [info vars {*_index}] {
  215.         global $i
  216.         unset $i
  217.     }
  218. }
  219.  
  220. proc procs::find {cmd} {
  221.     global auto_path
  222.     
  223.     regsub -all {[][\$?^|*+()\{\}]} $cmd {\\&} cmd
  224.     foreach path $auto_path {
  225.         if {![file exists $path]} continue
  226.         set index "[file tail $path]_index"
  227.         global $index
  228.         if {![info exists $index]} {
  229.             if {![file exists "$path:tclIndexx"]} continue
  230.             uplevel \#0 source [list "$path:tclIndexx"]
  231.         }
  232.         if {[regexp "\n\{(\[^\14\]+)\14\[^\n\]* \[\"\{\]?(::)?${cmd}\[\"\}\]? " [set $index] dummy file]} {
  233.             return "$path:$file"
  234.         }
  235.     }
  236.     return ""
  237. }
  238. # this proc adds 'dummy' so 'file dirname' works the same
  239. # way for tcl7.4 and tcl8.0.
  240. proc alpha::makeAutoPath {{check_dups 1} {skipPrefs 0}} {
  241.     global HOME auto_path
  242.     if $check_dups {
  243.         set lcmd lunion
  244.     } else {
  245.         set lcmd lappend
  246.     }
  247.     foreach dir {SystemCode Modes Menus} {
  248.         $lcmd auto_path $HOME:Tcl:$dir
  249.         foreach d [glob -nocomplain ${HOME}:Tcl:$dir:*:] {
  250.             $lcmd auto_path [file dirname "${d}dummy"]
  251.         }
  252.     }
  253.     if {!$skipPrefs} {
  254.         $lcmd auto_path $HOME:Tcl:Packages 
  255.         $lcmd auto_path $HOME:Tcl:UserModifications 
  256.         foreach d [glob -nocomplain $HOME:Tcl:Packages:*:] {
  257.             $lcmd auto_path [file dirname "${d}dummy"]
  258.         }
  259.     }
  260.     
  261. }
  262.  
  263. # Clean up temporary files:
  264. proc removeTemporaryFiles {} {
  265.     global PREFS
  266.     if [file exists "$PREFS:tmp"] {
  267.         foreach f [glob -nocomplain "$PREFS:tmp:*"] {
  268.             message "removing [file tail $f]…"
  269.             removeFile $f
  270.         }
  271.     }
  272.     message "all temporary files removed"
  273. }
  274. ## 
  275.  # -------------------------------------------------------------------------
  276.  # 
  277.  # "auto_reset" --
  278.  # 
  279.  #  After rebuilding indices, Tcl retains its old index information unless
  280.  #  we tell it not to.
  281.  # -------------------------------------------------------------------------
  282.  ##
  283. proc auto_reset {} {
  284.     global auto_path
  285.     foreach path $auto_path {
  286.         if {![file exists $path]} continue
  287.         set index "[file tail $path]_index"
  288.         global $index
  289.         catch {unset $index}
  290.     }
  291. }
  292.  
  293. #================================================================================
  294. # Wonderful procs from Vince Darley (darley@fas.harvard.edu).
  295. #===============================================================================
  296.  
  297. proc traceTclProc {} {
  298.     global tclMenu
  299.     if {[llength [traceFunc status]]>2} {
  300.         catch {markMenuItem $tclMenu {traceTclProc…} off}
  301.         catch {enableMenuItem $tclMenu dumpTraces off}
  302.         if {[string length [set data [traceDump]]]} {
  303.             if {[dialog::yesno "Dump traces?"]} {
  304.                 dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
  305.                 setWinInfo dirty 0
  306.             }
  307.         }
  308.         traceFunc off
  309.         message "Tracing off."
  310.         return
  311.     }
  312.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  313.         if {[info procs $sel] == "$sel"} {
  314.             set func $sel
  315.         } else {
  316.             set func [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
  317.         }
  318.     } else {
  319.         set func [listpick -p {Func Name:} [lsort -ignore [info procs]]]
  320.     }
  321.     if {![string length $func]} return
  322.     traceFunc on $func ""
  323.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  324.     catch {enableMenuItem $tclMenu dumpTraces on}
  325.     message "Tracing '$func'…"
  326. }
  327.  
  328.  
  329. proc dumpTraces {{name ""} {data ""}} {
  330.     if {![string length $name]} {
  331.         set name [string trimright [lindex [traceFunc status] 3] {,}]
  332.     }
  333.     if {![string length $data]} {
  334.         set data [traceDump]
  335.     }
  336.     
  337.     if {![string length $data]} {
  338.         message "Trace buffer empty"
  339.     } else {
  340.         regsub -all {:} $name {.} name
  341.         new -n "* Trace '$name' *" -m Tcl
  342.         insertText $data
  343.         winReadOnly
  344.     }
  345. }
  346.  
  347.  
  348. proc rebuildTclIndices {} {
  349.     global auto_path
  350.     set d [pwd]
  351.     foreach dir $auto_path {
  352.         # in case auto_path contains relative directories (bad idea)
  353.         cd
  354.         # if directory exists
  355.         if { ![catch { cd $dir } ] } {
  356.             # if there are any files
  357.             if { ![catch { glob *.*tcl } ] } {
  358.                 message "Building [file tail $dir] index…"                
  359.                 # use 'catch' also in case directory is write-protected
  360.                 catch { auto_mkindex : *.*tcl }
  361.             }
  362.         }
  363.     }
  364.     message ""
  365.     cd $d
  366.     # make alpha forget its old information so the new stuff is loaded
  367.     # when required.
  368.     catch {auto_reset}
  369. }
  370.  
  371. set alpha::rebuilding 0
  372.  
  373. proc alpha::rebuildPackageIndices {} {
  374.     set n [lsort -ignore [alpha::package names]]
  375.     alpha::makeIndices
  376.     if {[lsort -ignore [alpha::package names]] == $n} { return }
  377.     global package::loaded
  378.     set unk [lremove -l ${package::loaded} [alpha::package names]]
  379.     set package::loaded [lremove -l ${package::loaded} $unk]
  380.     # update extensions
  381.     package::makeMenu
  382.     # update package menus (uncomment if we change things so
  383.     # the list of package-menus is updated above)
  384.     #menu::buildSome global
  385.     message "Indices and package menu rebuilt."
  386. }
  387.  
  388. proc alpha::makeIndices {} {
  389.     # add all new directories to the auto_path
  390.     alpha::makeAutoPath
  391.     set types {index::extension index::mode index::menu index::uninstall \
  392.       index::maintainer index::help index::disable}
  393.     global pkg_file HOME alpha::rebuilding alpha::version
  394.     eval global $types
  395.     catch {eval cache::delete $types}
  396.     foreach type $types {
  397.         catch {unset $type}
  398.     }
  399.     foreach dir [list SystemCode:CorePackages Modes Menus Packages] {
  400.         lappend dirs "${HOME}:Tcl:${dir}:"
  401.         eval lappend dirs [glob -nocomplain "${HOME}:Tcl:${dir}:*:"]
  402.     }
  403.     set alpha::rebuilding 1
  404.     # provide the 'Alpha' package
  405.     alpha::extension Alpha ${alpha::version} {}
  406.     # now scan
  407.     foreach d $dirs {
  408.         lappend dirspats "${d}*.tcl"
  409.     }
  410.     set filenames [eval [list grepnames \
  411.       "^alpha::(menu|mode|extension|package (uninstall|disable|maintainer|help))"] $dirspats]
  412.     catch {
  413.         global rebuild_cmd_count
  414.         while {[set f [lindex $filenames 0]] != ""} {
  415.             set rebuild_cmd_count 1
  416.             while {[lindex $filenames $rebuild_cmd_count] == $f} {
  417.                 incr rebuild_cmd_count
  418.             }
  419.             set filenames [lrange $filenames $rebuild_cmd_count end]
  420.             set pkg_file $f
  421.             message "scanning $f…"
  422.             if {[catch {uplevel \#0 [list source $f]} res] != 11} {
  423.                 alertnote "Had a problem extracting package information from [file tail $f]"
  424.             }
  425.         }
  426.         unset rebuild_cmd_count
  427.     }
  428.     set alpha::rebuilding 0
  429.     foreach type $types {
  430.         cache::add $type "variable" $type
  431.         if {$type != "index::extension"} { catch {unset $type} }
  432.     }
  433.     unset pkg_file 
  434.     message "Package index rebuilt."
  435. }
  436.  
  437. # 'exit' kills Alpha without allowing it to save etc.
  438. # 'quit' is therefore more mac-like
  439. rename exit ""
  440. proc exit {} {quit}
  441.  
  442. proc alpha::error {string} {
  443.     global reportErrors
  444.     if $reportErrors {
  445.         alertnote [string range $string 0 200]
  446.     } else {
  447.         global alpha::errorLog
  448.         append alpha::errorLog $string
  449.     }
  450. }
  451.  
  452. proc alpha::errorAlert {text} {
  453.     alertnote $text
  454.     error $text
  455. }
  456.  
  457. namespace eval flag {}
  458.  
  459. # ALWAYS USE THIS PROC
  460. proc flag::addType {type} {
  461.     global flag::types
  462.     if {[lsearch -exact ${flag::types} $type] == -1} {
  463.         lappend flag::types $type
  464.     }
  465. }
  466.  
  467. # NEVER MESS WITH THIS VARIABLE DIRECTLY
  468. set flag::types [list "flag" "variable" "binding" "menubinding" "file" "io-file"]
  469. # Note: other types are triggered by vars ending in 'Colour', 'Color',
  470. # 'Folder', 'Path', 'Mode', 'Sig', or 'SearchPath'
  471.  
  472. ## 
  473.  # -------------------------------------------------------------------------
  474.  # 
  475.  # "newPref" --
  476.  # 
  477.  #  Define a new preference variable/flag.  You can call this procedure
  478.  #  either with multiple arguments or with a single list of all the
  479.  #  arguments.  So 'newPref flag Hey ...' or 'newPref {flag Hey ...}'
  480.  #  are both fine.
  481.  #  
  482.  #  'type' is one of:
  483.  #    'flag' (on/off only), 'variable' (anything), 'binding' (key-combo)
  484.  #    'menubinding' (key-combo which works in a menu), 'file' (input only),
  485.  #    'io-file' (either input or output).  Variables whose name ends in
  486.  #    Sig, Folder, Path, Mode, Colour, Color or SearchPath (case matters here) 
  487.  #    are treated differently, but are still considered of type 'variable'.
  488.  #    For convenience this proc will map types sig, folder, color, ...
  489.  #    into 'variable' for you, _if_ the variable ends with the correct
  490.  #    string.
  491.  #    
  492.  #  'name' is the var name, 
  493.  #  
  494.  #  'val' is its default value (which will be ignored if the variable
  495.  #  already has a value)
  496.  #  
  497.  #  'pkg' is either 'global' to mean a global preference, or the name 
  498.  #  of the mode or package (no spaces) for which this is a preference.
  499.  #  
  500.  #  'pname' is a procedure to call if this preference is changed by
  501.  #  the user (no need to setup a trace).  This proc is only called
  502.  #  for changes made through prefs dialogs or prefs menus created by
  503.  #  Alpha's core procs.  Other changes are not traced.
  504.  #  
  505.  #  Depending on the previous values, there are two optional arguments
  506.  #  with the following uses:
  507.  #  
  508.  #  TYPE:
  509.  #  
  510.  #  variable:
  511.  #  
  512.  #  'options' is a list of items from which this preference takes a single
  513.  #  item.
  514.  #  'subopt' is any of 'item', 'index', 'varitem' or 'varindex' or 'array', where
  515.  #  'item' indicates the pref is simply an item from the given list
  516.  #  of items, 'index' indicates it is an index into that list, and
  517.  #  'var*' indicates 'items' is in fact the name of a global variable
  518.  #  which contains the list. 'array' means take one of the values from an array.
  519.  #  If no value is given, 'item' is the default
  520.  #  
  521.  #  binding:
  522.  #  
  523.  #  'options' is the name of a proc to which this item should be bound.
  524.  #  If options = '1', then we bind to the proc with the same name as
  525.  #  this variable.  Otherwise we do not perform automatic bindings.
  526.  #  
  527.  #  'subopt' indicates whether the binding is mode-specific or global.
  528.  #  It should either be 'global' or the name of a mode.  If not given,
  529.  #  it defaults to 'global' for all non-modes, and to mode-specific for
  530.  #  all packages.  (Alpha tests if something is a mode by the existence
  531.  #  of modeMenus($mode))
  532.  # -------------------------------------------------------------------------
  533.  ##
  534. proc newPref {vtype {name {}} {val 0} {pkg "global"} {pname ""} {options ""} {subopt ""}} {
  535.     if {$name == {}} { uplevel 1 newPref $vtype}
  536.     global allFlags allVars tclvars modeVars flag::procs \
  537.       flag::type flag::types
  538.     set bad 1
  539.     foreach ty ${flag::types} {
  540.         if {[string first $vtype $ty] == 0} {
  541.             set vtype $ty
  542.             set bad 0
  543.             break
  544.         }
  545.     }
  546.     if $bad {
  547.         foreach ty {SearchPath Folder Path Mode Colour Color Sig} {
  548.             if {[string first $vtype [string tolower $ty]] == 0} {
  549.                 if [regexp "${ty}\$" $name] {
  550.                     set vtype variable
  551.                     set bad 0
  552.                     break
  553.                 } else {
  554.                     error "Type '$vtype' requires the variable's name to end in '$ty'"
  555.                 }
  556.             }
  557.         }
  558.         if $bad {error "Unknown type '$vtype' in call to newPref"}
  559.     }
  560.     if {$pkg == "global"} {
  561.         switch -- $vtype {
  562.             "flag" {
  563.                 lappend allFlags $name
  564.             }
  565.             "variable" {
  566.                 lappend allVars $name
  567.             }
  568.             default {
  569.                 set flag::type($name) $vtype
  570.                 lappend allVars $name
  571.             }
  572.         }
  573.     
  574.         global $name
  575.         lunion tclvars $name
  576.         if {![info exists $name]} {set $name $val} else { set val [set $name] }
  577.     } else {
  578.         global ${pkg}modeVars
  579.         lunion modeVars $name
  580.         
  581.         if {![info exists ${pkg}modeVars($name)]} {
  582.             set ${pkg}modeVars($name) $val
  583.         } else {
  584.             set val [set ${pkg}modeVars($name)]
  585.         }
  586.         switch -- $vtype {
  587.             "flag" {
  588.                 lunion allFlags $name
  589.             }
  590.             "variable" {
  591.             }
  592.             default {
  593.                 set flag::type($name) $vtype
  594.                 lappend allVars $name
  595.             }
  596.         }
  597.     }
  598.     # handle 'options'
  599.     if {$options != ""} {
  600.         switch -- $vtype {
  601.             "variable" {
  602.                 global flag::list
  603.                 if {$subopt == ""} { set subopt "item" }
  604.                 if {[lsearch -exact "array item index varitem varindex" $subopt] == -1} {
  605.                     error "Unknown list element type '$subopt' in call to newPref."
  606.                 }
  607.                 set flag::list($name) [list $subopt $options]
  608.             }
  609.             "binding" {
  610.                 global flag::binding modeMenus
  611.                 if [info exists modeMenus($pkg)] {
  612.                     if {$subopt == ""} { 
  613.                         set subopt $pkg
  614.                     } else {
  615.                         if {$subopt == "global"} { set subopt "" }
  616.                     }
  617.                 } 
  618.                 set flag::binding($name) [list $subopt $options]
  619.                 if {$options == 1} { set options $name }
  620.                 
  621.                 catch "bind [keys::toBind $val] [list $options] $subopt"
  622.             }
  623.         }
  624.     }
  625.     # register the 'modify' proc
  626.     if {[string length $pname]} {
  627.         set flag::procs($name) $pname
  628.     }
  629. }
  630.  
  631.  
  632. set alpha::patchlevel ""
  633. append alpha::version ${alpha::patchlevel}
  634.